home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / macros.lsp < prev    next >
Lisp/Scheme  |  1992-09-13  |  31KB  |  911 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Macros global variable definitions, and other random support stuff used
  28. ;;; by the rest of the system.
  29. ;;;
  30. ;;; For simplicity (not having to use eval-when a lot), this file must be
  31. ;;; loaded before it can be compiled.
  32. ;;;
  33.  
  34. (in-package 'pcl)
  35.  
  36. (proclaim '(declaration
  37.          #-Genera values          ;I use this so that Zwei can remind
  38.                       ;me what values a function returns.
  39.          
  40.          #-Genera arglist          ;Tells me what the pretty arglist
  41.                       ;of something (which probably takes
  42.                       ;&rest args) is.
  43.  
  44.          #-Genera indentation     ;Tells ZWEI how to indent things
  45.                           ;like defclass.
  46.          class
  47.          variable-rebinding
  48.          pcl-fast-call
  49.          specializer-names
  50.          ))
  51.  
  52. ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
  53. ;;; in other packages in all CommonLisp implementations, but I will leave it
  54. ;;; to the compiler to optimize into calls to them.
  55. ;;;
  56. ;;; Common Lisp BUG:
  57. ;;;    Some Common Lisps define these in the Lisp package which causes
  58. ;;;    all sorts of lossage.  Common Lisp should explictly specify which
  59. ;;;    symbols appear in the Lisp package.
  60. ;;;
  61. (eval-when (compile load eval)
  62.  
  63. (defmacro memq (item list) `(member ,item ,list :test #'eq))
  64. (defmacro assq (item list) `(assoc ,item ,list :test #'eq))
  65. (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
  66. (defmacro delq (item list) `(delete ,item ,list :test #'eq))
  67. (defmacro posq (item list) `(position ,item ,list :test #'eq))
  68. (defmacro neq (x y) `(not (eq ,x ,y)))
  69.  
  70.  
  71. (defun make-caxr (n form)
  72.   (declare (type fixnum n))
  73.   (if (< n 4)
  74.       `(,(nth n '(car cadr caddr cadddr)) ,form)
  75.       (make-caxr (the fixnum (- n 4)) `(cddddr ,form))))
  76.  
  77. (defun make-cdxr (n form)
  78.   (declare (type fixnum n))
  79.   (cond ((zerop n) form)
  80.     ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
  81.     (t (make-cdxr (the fixnum (- n 4)) `(cddddr ,form)))))
  82. )
  83.  
  84.  
  85. (defun true (&rest ignore) (declare (ignore ignore)) t)
  86. (defun false (&rest ignore) (declare (ignore ignore)) nil)
  87. (defun zero (&rest ignore) (declare (ignore ignore)) 0)
  88. (defvar *keyword-package* (find-package 'keyword))
  89.  
  90. (defun make-plist (keys vals)
  91.   (if (null vals)
  92.       ()
  93.       (list* (car keys)
  94.          (car vals)
  95.          (make-plist (cdr keys) (cdr vals)))))
  96.  
  97. (defun remtail (list tail)
  98.   (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
  99.  
  100. ;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just
  101. ;;; lifted it from there but I am honest.  Not only that but this one is
  102. ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
  103. ;;; like rebuilding Rome.
  104. ;;;
  105. ;;; Modified 5/8/92 to work right on THE forms and to not  wrap an
  106. ;;; extra lambda if none of the variables are complex -- TL.
  107.  
  108. (defun un-the (form)
  109.   "Returns the actual form within a form that may start with THE."
  110.   (if (and (listp form) (eq (car form) 'the))
  111.       (un-the (third form))
  112.       form))
  113.  
  114. (defun simple-eval-access-p (form)
  115.   "Returns whether evaluation of the form is 'simple', i.e. does not
  116.    require computation to calculate.  This is true of constants, variables,
  117.    and functions."
  118.   (or (constantp form)                ;; Form is a constant?
  119.       (symbolp   form)                ;; Form is a variable?
  120.       (and (listp form)
  121.            (eq (car form) 'function)) ;; Form is a function?
  122.       (and (listp form)               ;; If form starts with THE, the real form
  123.            (eq (car form) 'the)       ;;   third element.
  124.            (simple-eval-access-p (third form)))))
  125.  
  126. (defmacro once-only (vars &body body)
  127.   (let ((gensym-var (gensym))
  128.         (run-time-vars (gensym "RUN-TIME-VARS"))
  129.         (run-time-vals (gensym "RUN-TIME-VALS"))
  130.         (expand-time-val-forms ()))
  131.     (dolist (var vars)
  132.       (push `(if (simple-eval-access-p ,var)
  133.                  ,var
  134.                  (let ((,gensym-var (gensym ,(symbol-name var))))
  135.                    (push ,gensym-var ,run-time-vars)
  136.                    (push ,var ,run-time-vals)
  137.                    ,gensym-var))
  138.             expand-time-val-forms))
  139.     `(let* (,run-time-vars
  140.             ,run-time-vals
  141.             (wrapped-body
  142.           (let ,(mapcar #'list vars (reverse expand-time-val-forms))
  143.         ,@body)))
  144.        (if ,run-time-vars
  145.            `(let ,(mapcar #'list (reverse ,run-time-vars)
  146.                                  (reverse ,run-time-vals))
  147.              ,wrapped-body)
  148.          wrapped-body))))
  149.  
  150. (defun declaimed-p-name (name)
  151.   (if (consp name)
  152.       (get-internal-setf-function-name (cadr name))
  153.       name))
  154.  
  155. #-(or cmu)  ; And probably others, but this is the only I know.
  156. (unless (fboundp 'declaim)
  157.   (defmacro declaim (&rest decl-specs)
  158.     (let ((proclamations NIL))
  159.       (declare (list proclamations))
  160.       (dolist (decl-spec decl-specs)
  161.         #-(or cmu kcl)
  162.         (when (eq (car decl-spec) 'ftype)
  163.           (dolist (name (cddr decl-spec))
  164.             (setf (get (declaimed-p-name name) 'ftype-declaimed-p) T)))
  165.         (push `(proclaim ',decl-spec) proclamations))
  166.       (if (cdr proclamations)
  167.           `(progn ,@proclamations)
  168.           (car proclamations)))))
  169.  
  170. #-(or cmu kcl)
  171. (defun function-ftype-declaimed-p (name)
  172.   "Returns whether the function given by name already has its ftype declaimed."
  173.   (get (declaimed-p-name name) 'ftype-declaimed-p))
  174.  
  175.  
  176. (deftype index () `(integer 0 ,most-positive-fixnum))
  177.  
  178. (defmacro pop-key-value (key
  179.                          settable-lambda-list
  180.                          &optional
  181.                          default-value)
  182.   ;;   If key is on the settable-lambda-list, then it and its value is
  183.   ;; destructively removed from the list, and its value is returned.
  184.   ;;   Else, default-value is returned and the settable-lambda-list
  185.   ;; stays the same.
  186.   (once-only (key)
  187.     `(let ((list-ptr ,settable-lambda-list))
  188.         (if (eq (car list-ptr) ,key)
  189.             (progn
  190.               (setf ,settable-lambda-list (cddr list-ptr))
  191.               (cadr list-ptr))
  192.           (progn
  193.             (setf list-ptr (cdr list-ptr))
  194.             (let ((next-cdr (cdr list-ptr)))
  195.               (loop (when (null next-cdr)
  196.                       (return ,default-value))
  197.                     (when (eq (car next-cdr) ,key)
  198.                       (setf (cdr list-ptr) (cddr next-cdr))
  199.                       (return (cadr next-cdr)))
  200.                     (setf next-cdr
  201.                           (cdr (setf list-ptr (cdr next-cdr)))))))))))
  202.  
  203. (defmacro copy-simple-vector (orig)
  204.   "Fast way to copy a simple-vector."
  205.   #-kcl
  206.   (once-only (orig)
  207.     `(let* ((i   0)
  208.             (n   (length (the simple-vector ,orig)))
  209.             (new (make-array n)))
  210.        (declare (type index i n) (type simple-vector new))
  211.        (tagbody
  212.          begin-loop
  213.            (if (>= i n) (go end-loop))
  214.            (setf (svref new i) (svref (the simple-vector ,orig) i))
  215.            (setf i (the index (1+ i)))
  216.